home *** CD-ROM | disk | FTP | other *** search
/ Ultra Pack / UltraComputing Partner Applications.iso / SunLabs / tclTK / src / tcl7.4 / library / init.tcl next >
Text File  |  1995-06-08  |  8KB  |  278 lines
  1. # init.tcl --
  2. #
  3. # Default system startup file for Tcl-based applications.  Defines
  4. # "unknown" procedure and auto-load facilities.
  5. #
  6. # @(#) init.tcl 1.37 95/03/29 10:26:32
  7. #
  8. # Copyright (c) 1991-1993 The Regents of the University of California.
  9. # Copyright (c) 1994 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15. set auto_path [info library]
  16. set errorCode ""
  17. set errorInfo ""
  18.  
  19. # unknown:
  20. # Invoked when a Tcl command is invoked that doesn't exist in the
  21. # interpreter:
  22. #
  23. #    1. See if the autoload facility can locate the command in a
  24. #       Tcl script file.  If so, load it and execute it.
  25. #    2. If the command was invoked interactively at top-level:
  26. #        (a) see if the command exists as an executable UNIX program.
  27. #        If so, "exec" the command.
  28. #        (b) see if the command requests csh-like history substitution
  29. #        in one of the common forms !!, !<number>, or ^old^new.  If
  30. #        so, emulate csh's history substitution.
  31. #        (c) see if the command is a unique abbreviation for another
  32. #        command.  If so, invoke the command.
  33.  
  34. proc unknown args {
  35.     global auto_noexec auto_noload env unknown_pending tcl_interactive
  36.     global errorCode errorInfo
  37.  
  38.     # Save the values of errorCode and errorInfo variables, since they
  39.     # may get modified if caught errors occur below.  The variables will
  40.     # be restored just before re-executing the missing command.
  41.  
  42.     set savedErrorCode $errorCode
  43.     set savedErrorInfo $errorInfo
  44.     set name [lindex $args 0]
  45.     if ![info exists auto_noload] {
  46.     #
  47.     # Make sure we're not trying to load the same proc twice.
  48.     #
  49.     if [info exists unknown_pending($name)] {
  50.         unset unknown_pending($name)
  51.         if {[array size unknown_pending] == 0} {
  52.         unset unknown_pending
  53.         }
  54.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  55.     }
  56.     set unknown_pending($name) pending;
  57.     set ret [catch {auto_load $name} msg]
  58.     unset unknown_pending($name);
  59.     if {$ret != 0} {
  60.         return -code $ret "error while autoloading \"$name\": $msg"
  61.     }
  62.     if ![array size unknown_pending] {
  63.         unset unknown_pending
  64.     }
  65.     if $msg {
  66.         set errorCode $savedErrorCode
  67.         set errorInfo $savedErrorInfo
  68.         set code [catch {uplevel $args} msg]
  69.         if {$code ==  1} {
  70.         #
  71.         # Strip the last five lines off the error stack (they're
  72.         # from the "uplevel" command).
  73.         #
  74.  
  75.         set new [split $errorInfo \n]
  76.         set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
  77.         return -code error -errorcode $errorCode \
  78.             -errorinfo $new $msg
  79.         } else {
  80.         return -code $code $msg
  81.         }
  82.     }
  83.     }
  84.     if {([info level] == 1) && ([info script] == "") \
  85.         && [info exists tcl_interactive] && $tcl_interactive} {
  86.     if ![info exists auto_noexec] {
  87.         if [auto_execok $name] {
  88.         set errorCode $savedErrorCode
  89.         set errorInfo $savedErrorInfo
  90.         return [uplevel exec >&@stdout <@stdin $args]
  91.         }
  92.     }
  93.     set errorCode $savedErrorCode
  94.     set errorInfo $savedErrorInfo
  95.     if {$name == "!!"} {
  96.         return [uplevel {history redo}]
  97.     }
  98.     if [regexp {^!(.+)$} $name dummy event] {
  99.         return [uplevel [list history redo $event]]
  100.     }
  101.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  102.         return [uplevel [list history substitute $old $new]]
  103.     }
  104.     set cmds [info commands $name*]
  105.     if {[llength $cmds] == 1} {
  106.         return [uplevel [lreplace $args 0 0 $cmds]]
  107.     }
  108.     if {[llength $cmds] != 0} {
  109.         if {$name == ""} {
  110.         return -code error "empty command name \"\""
  111.         } else {
  112.         return -code error \
  113.             "ambiguous command name \"$name\": [lsort $cmds]"
  114.         }
  115.     }
  116.     }
  117.     return -code error "invalid command name \"$name\""
  118. }
  119.  
  120. # auto_load:
  121. # Checks a collection of library directories to see if a procedure
  122. # is defined in one of them.  If so, it sources the appropriate
  123. # library file to create the procedure.  Returns 1 if it successfully
  124. # loaded the procedure, 0 otherwise.
  125.  
  126. proc auto_load cmd {
  127.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  128.  
  129.     if [info exists auto_index($cmd)] {
  130.     uplevel #0 $auto_index($cmd)
  131.     return [expr {[info commands $cmd] != ""}]
  132.     }
  133.     if [catch {set path $auto_path}] {
  134.     if [catch {set path $env(TCLLIBPATH)}] {
  135.         if [catch {set path [info library]}] {
  136.         return 0
  137.         }
  138.     }
  139.     }
  140.     if [info exists auto_oldpath] {
  141.     if {$auto_oldpath == $path} {
  142.         return 0
  143.     }
  144.     }
  145.     set auto_oldpath $path
  146.     catch {unset auto_index}
  147.     for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} {
  148.     set dir [lindex $path $i]
  149.     set f ""
  150.     if [catch {set f [open $dir/tclIndex]}] {
  151.         continue
  152.     }
  153.     set error [catch {
  154.         set id [gets $f]
  155.         if {$id == "# Tcl autoload index file, version 2.0"} {
  156.         eval [read $f]
  157.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  158.         while {[gets $f line] >= 0} {
  159.             if {([string index $line 0] == "#")
  160.                 || ([llength $line] != 2)} {
  161.             continue
  162.             }
  163.             set name [lindex $line 0]
  164.             set auto_index($name) "source $dir/[lindex $line 1]"
  165.         }
  166.         } else {
  167.         error "$dir/tclIndex isn't a proper Tcl index file"
  168.         }
  169.     } msg]
  170.     if {$f != ""} {
  171.         close $f
  172.     }
  173.     if $error {
  174.         error $msg $errorInfo $errorCode
  175.     }
  176.     }
  177.     if [info exists auto_index($cmd)] {
  178.     uplevel #0 $auto_index($cmd)
  179.     if {[info commands $cmd] != ""} {
  180.         return 1
  181.     }
  182.     }
  183.     return 0
  184. }
  185.  
  186. # auto_execok:
  187. # Returns 1 if there's an executable in the current path for the
  188. # given name, 0 otherwise.  Builds an associative array auto_execs
  189. # that caches information about previous checks, for speed.
  190.  
  191. proc auto_execok name {
  192.     global auto_execs env
  193.  
  194.     if [info exists auto_execs($name)] {
  195.     return $auto_execs($name)
  196.     }
  197.     set auto_execs($name) 0
  198.     if {[string first / $name] >= 0} {
  199.     if {[file executable $name] && ![file isdirectory $name]} {
  200.         set auto_execs($name) 1
  201.     }
  202.     return $auto_execs($name)
  203.     }
  204.     foreach dir [split $env(PATH) :] {
  205.     if {$dir == ""} {
  206.         set dir .
  207.     }
  208.     if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} {
  209.         set auto_execs($name) 1
  210.         return 1
  211.     }
  212.     }
  213.     return 0
  214. }
  215.  
  216. # auto_reset:
  217. # Destroy all cached information for auto-loading and auto-execution,
  218. # so that the information gets recomputed the next time it's needed.
  219. # Also delete any procedures that are listed in the auto-load index
  220. # except those related to auto-loading.
  221.  
  222. proc auto_reset {} {
  223.     global auto_execs auto_index auto_oldpath
  224.     foreach p [info procs] {
  225.     if {[info exists auto_index($p)] && ($p != "unknown")
  226.         && ![string match auto_* $p]} {
  227.         rename $p {}
  228.     }
  229.     }
  230.     catch {unset auto_execs}
  231.     catch {unset auto_index}
  232.     catch {unset auto_oldpath}
  233. }
  234.  
  235. # auto_mkindex:
  236. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  237. # the name of the directory in which the tclIndex file is to be placed,
  238. # floowed by any number of glob patterns to use in that directory to
  239. # locate all of the relevant files.
  240.  
  241. proc auto_mkindex {dir args} {
  242.     global errorCode errorInfo
  243.     set oldDir [pwd]
  244.     cd $dir
  245.     set dir [pwd]
  246.     append index "# Tcl autoload index file, version 2.0\n"
  247.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  248.     append index "# and sourced to set up indexing information for one or\n"
  249.     append index "# more commands.  Typically each line is a command that\n"
  250.     append index "# sets an element in the auto_index array, where the\n"
  251.     append index "# element name is the name of a command and the value is\n"
  252.     append index "# a script that loads the command.\n\n"
  253.     foreach file [eval glob $args] {
  254.     set f ""
  255.     set error [catch {
  256.         set f [open $file]
  257.         while {[gets $f line] >= 0} {
  258.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  259.             append index "set [list auto_index($procName)]"
  260.             append index " \"source \$dir/$file\"\n"
  261.         }
  262.         }
  263.         close $f
  264.     } msg]
  265.     if $error {
  266.         set code $errorCode
  267.         set info $errorInfo
  268.         catch {close $f}
  269.         cd $oldDir
  270.         error $msg $info $code
  271.     }
  272.     }
  273.     set f [open tclIndex w]
  274.     puts $f $index nonewline
  275.     close $f
  276.     cd $oldDir
  277. }
  278.